home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / primops / m68primops.t < prev    next >
Encoding:
Text File  |  1990-06-19  |  10.6 KB  |  274 lines
  1. (herald m68primops
  2.         (env (make-empty-early-binding-locale 'nil) constants))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define-constant call-foreign 
  28.   (primop call-foreign ()
  29.     ((primop.special? self) t)
  30.     ((primop.make-closed self)
  31.      '(lambda args (error "DEFINE-FOREIGN cannot be interpreted")))
  32.     ((primop.generate self node)
  33.      (generate-foreign-call node))))
  34.  
  35. ;;; COMPARATORS
  36. ;;;===========================================================================
  37.  
  38. (define-constant eq?
  39.   (primop eq? ()
  40.     ((primop.generate self node)
  41.      (eq?-comparator node))
  42.     ((primop.presimplify self node)
  43.      (presimplify-to-conditional node))
  44.     ((primop.make-closed self)
  45.      (make-closed-conditional self))
  46.     ((primop.conditional? self) t)
  47.     ((primop.conditional-type self node)
  48.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  49.     ((primop.type self node)
  50.      '#[type (proc #f (proc #f boolean) top top)])))
  51.        
  52. ;;; TYPE PREDICATES
  53. ;;;===========================================================================
  54.  
  55. (define-local-syntax (define-type-predicate name variant . rest)
  56.   `(define-constant ,name
  57.      ,(xcase variant
  58.         ((and)
  59.          `(make-and-type-predicate ',name . ,rest))
  60.         ((header)
  61.          `(make-header-type-predicate ',name . ,rest)))))
  62.  
  63. (define-constant make-and-type-predicate 
  64.   (primop make-and-type-predicate (name mask value)
  65.  
  66.     (((primop.simplify self node)
  67.       (simplify-parameterized-primop self node)))
  68.  
  69.     ((primop.test-code self node arg)      
  70.      (emit m68/move .l arg SCRATCH)
  71.      (emit m68/and .b (machine-num mask) SCRATCH)
  72.      (emit m68/cmp .b  (machine-num value) SCRATCH))
  73.     ((primop.presimplify self node)
  74.      (presimplify-predicate node))
  75.     ((primop.make-closed self)
  76.      (make-closed-predicate self))
  77.     ((primop.type-predicate? self) t)
  78.     ((primop.type self node)
  79.      '#[type (proc #f (proc #f boolean) top)])
  80.     ((primop.predicate-type self node)
  81.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  82.     ((primop.variant-id self) name)))
  83.  
  84. (define-constant make-header-type-predicate
  85.   (primop make-header-type-predicate (name header)
  86.  
  87.     (((primop.simplify self node)
  88.       (simplify-parameterized-primop self node)))
  89.  
  90.     ((primop.test-code self node arg)
  91.      (emit m68/move .l arg SCRATCH)
  92.      (emit m68/rol .l (machine-num 1) SCRATCH)
  93.      (emit m68/cmp .b (machine-num (fx* header 2)) SCRATCH))
  94.     ((primop.presimplify self node)
  95.      (presimplify-predicate node))
  96.     ((primop.make-closed self)
  97.      (make-closed-predicate self))
  98.     ((primop.type-predicate? self) t)
  99.     ((primop.type self node)
  100.      '#[type (proc #f (proc #f boolean) top)])
  101.     ((primop.predicate-type self node)
  102.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  103.     ((primop.variant-id self) name)))
  104.  
  105.                      
  106. (define-type-predicate list?        and 3 tag/pair)         ; low 2 bits
  107. (define-type-predicate extend?      and 3 tag/extend)
  108. (define-type-predicate immediate?   and 3 tag/immediate)
  109.  
  110. (define-type-predicate general-vector-header? header header/general-vector)
  111. (define-type-predicate bytev-header?          header header/bytev)
  112. (define-type-predicate text-header?           header header/text)
  113. (define-type-predicate string-header?         header header/slice)
  114. (define-type-predicate symbol-header?         header header/symbol)
  115. (define-type-predicate foreign-header?        header header/foreign)
  116. (define-type-predicate vcell-header?          header header/vcell)
  117. (define-type-predicate true-header?           header header/true)
  118. (define-type-predicate unit-header?           header header/unit)
  119. (define-type-predicate vframe-header?         header header/vframe)
  120. (define-type-predicate bignum-header?         header header/bignum) 
  121. (define-type-predicate double-float-header?   header header/double-float)
  122. (define-type-predicate fault-frame-header?    header header/fault-frame)
  123.                        
  124. (define-type-predicate weak-set-header?   header header/weak-set)
  125. (define-type-predicate weak-alist-header? header header/weak-alist)
  126. (define-type-predicate weak-table-header? header header/weak-table)
  127. (define-type-predicate weak-cell-header?  header header/weak-cell)
  128.  
  129. (define-constant char?
  130.   (primop char? ()
  131.     ((primop.test-code self node arg)
  132.      (emit m68/move .l arg SCRATCH)
  133.      (emit m68/cmp .b (machine-num header/char) SCRATCH))
  134.     ((primop.presimplify self node)
  135.      (presimplify-predicate node))
  136.     ((primop.make-closed self)
  137.      (make-closed-predicate self))
  138.     ((primop.type-predicate? self) t)
  139.     ((primop.type self node)
  140.      '#[type (proc #f (proc #f boolean) top)])
  141.     ((primop.predicate-type self node)
  142.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  143.                                                       
  144. (define-constant fixnum?
  145.   (primop fixnum? ()
  146.     ((primop.test-code self node arg)
  147.      (emit m68/move .l arg SCRATCH)
  148.      (emit m68/and .b (machine-num 3) SCRATCH))
  149.     ((primop.presimplify self node)
  150.      (presimplify-predicate node))
  151.     ((primop.make-closed self)
  152.      (make-closed-predicate self))
  153.     ((primop.type-predicate? self) t)
  154.     ((primop.type self node)
  155.      '#[type (proc #f (proc #f boolean) top)])
  156.     ((primop.predicate-type self node)
  157.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  158.                                                       
  159. (define-constant nonvalue?
  160.   (primop nonvalue? ()
  161.     ((primop.test-code self node arg)
  162.      (emit m68/move .l arg SCRATCH)
  163.      (emit m68/cmp .b (machine-num header/nonvalue) SCRATCH))
  164.     ((primop.presimplify self node)
  165.      (presimplify-predicate node))
  166.     ((primop.make-closed self)
  167.      (make-closed-predicate self))
  168.     ((primop.type-predicate? self) t)
  169.     ((primop.type self node)
  170.      '#[type (proc #f (proc #f boolean) top)])
  171.     ((primop.predicate-type self node)
  172.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  173.                                                       
  174.  
  175. (define-constant template-header?
  176.   (primop template-header? ()
  177.     ((primop.test-code self node arg)
  178.      (emit m68/move .l arg SCRATCH)
  179.      (emit m68/btst (machine-num 31) SCRATCH))
  180.     ((primop.presimplify self node)
  181.      (presimplify-predicate node))
  182.     ((primop.make-closed self)
  183.      (make-closed-predicate self))
  184.     ((primop.jump-on-equal? self) t)      
  185.     ((primop.type-predicate? self) t)
  186.     ((primop.type self node)
  187.      '#[type (proc #f (proc #f boolean) top)])
  188.     ((primop.predicate-type self node)
  189.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  190.                                                 
  191.  
  192. ;;; MAKE-VECTORS
  193. ;;;=========================================================================
  194.  
  195. (define-constant make-vector-extend
  196.   (primop make-vector-extend ()
  197.     ((primop.arg-specs self) '(* 10 1))   ;; AN and S1
  198.     ((primop.generate self node)
  199.      (generate-make-vector-extend node))))
  200.  
  201. (define-constant %make-extend
  202.   (primop %make-extend ()
  203.     ((primop.arg-specs self) '(10 1))   ;; AN and S1
  204.     ((primop.generate self node)
  205.      (generate-make-extend node))
  206.     ((primop.type self node)
  207.      '#[type (proc #f (proc #f top) template fixnum)])))
  208.  
  209. ;;; MAKE-PAIR
  210.  
  211. (define-constant %make-pair
  212.   (primop %make-pair ()
  213.     ((primop.generate self node)
  214.      (generate-make-pair node))
  215.     ((primop.type self node)
  216.      '#[type (proc #f (proc #f pair))])))
  217.  
  218. ;;; ONE-ARG-PRIMITIVES
  219. ;;;==========================================================================
  220.                       
  221. (define-constant descriptor->fixnum
  222.   (primop descriptor->fixnum ()
  223.     ((primop.generate self node)
  224.      (receive (source target rep) (one-arg-primitive node)
  225.        (let ((reg (if (eq? (reg-type target) 'scratch)
  226.                       target
  227.                       (get-register 'scratch node '*))))
  228.          (generate-move source reg)
  229.          (emit m68/and .b (machine-num #xFC) reg)
  230.          (really-rep-convert node reg 'rep/pointer target rep)
  231.          (mark-continuation node target))))
  232.     ((primop.type self node)
  233.      '#[type (proc #f (proc #f fixnum) top)])))
  234.  
  235. (define-constant descriptor-tag
  236.   (primop descriptor-tag ()
  237.     ((primop.generate self node)
  238.      (receive (source target rep) (one-arg-primitive node)
  239.        (let ((reg (if (eq? (reg-type target) 'scratch)
  240.                       target
  241.                       (get-register 'scratch node '*))))
  242.          (generate-move source reg)
  243.          (emit m68/asl .b (machine-num 2) reg)
  244.          (emit m68/and .l (machine-num #xF) reg) ; get low 4 bits
  245.          (really-rep-convert node reg 'rep/pointer target rep)
  246.          (mark-continuation node target))))
  247.     ((primop.type self node)
  248.      '#[type (proc #f (proc #f fixnum) top)])))
  249.                                            
  250. (define-constant header-type
  251.   (primop header-type ()
  252.     ((primop.generate self node)
  253.      (receive (source target rep) (one-arg-primitive node)
  254.        (let ((reg (if (eq? (reg-type target) 'scratch)
  255.                       target
  256.                       (get-register 'scratch node '*))))
  257.          (generate-move source reg)
  258.          (emit m68/and .l (machine-num #x7c) reg) ; get low 7 bits
  259.          (really-rep-convert node reg 'rep/pointer target rep) ; mask out tag
  260.          (mark-continuation node target))))
  261.     ((primop.type self node)
  262.      '#[type (proc #f (proc #f fixnum) top)])))
  263.  
  264. (define-constant %chdr
  265.   (primop %chdr ()
  266.     ((primop.side-effects? self) t)
  267.     ((primop.generate self node)
  268.      (generate-%chdr node))))
  269.                             
  270.  
  271.  
  272.  
  273.  
  274.